home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 011-020 / amok16 / memsystem / memsystem.mod < prev    next >
Text File  |  1993-11-04  |  4KB  |  144 lines
  1. (**********************************************************************
  2.  
  3.     :Program.    MemSystem.mod
  4.     :Contents.   convenient memory allocation procedures
  5.     :Author.     Nicolas Benezan [bne]
  6.     :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
  7.     :Phone.      711/333679
  8.     :Copyright.  Public Domain
  9.     :Language.   Modula-2
  10.     :Translator. M2Amiga AMSoft 3.2d
  11.     :Imports.    ErrorReq,TaskMemory [bne]
  12.     :History.    V1.0b [bne] 17.Jun.88 (pre-version, private)
  13.     :History.    V1.1e [bne] 28.Oct.88 (Bug corrected)
  14.     :History.    V1.2b [bne] 27.Jan.89 (ErrorReq items excluded)
  15.     :History.    V1.3b [bne] 04.Mar.89 (+ NoCareDeallocate, Levels)
  16.     :Update.     [bne] 27.Jan.89 adaptions for m2cV3.2d
  17.  
  18. **********************************************************************)
  19.  
  20. IMPLEMENTATION MODULE MemSystem;
  21.  
  22. FROM SYSTEM     IMPORT ADR,ADDRESS,BYTE,CAST;
  23. FROM Exec       IMPORT MemReqSet,MemReqs,Forbid,Permit,AvailMem,UByte,
  24.                 Remove,FindTask,MemListPtr,TaskPtr,FreeEntry;
  25. FROM TaskMemory IMPORT AllocTaskMem,DeallocTaskMem,CHIP,ANY;
  26. FROM ErrorReq   IMPORT YesNoRequest,RETRY,CANCEL,ABORT,ExitQuiet;
  27. FROM Arts       IMPORT Assert;
  28.  
  29. CONST   StdMinMem=20*1024;
  30.         StdHysteresis=30*1024;
  31.  
  32.         (* Messages *)
  33.         Warning=    "Low memory warning";
  34.         TwiceFreed= "can't Free() free Memory";
  35.  
  36. TYPE    LevelKey=LONGINT;
  37.  
  38. PROCEDURE Alloc(VAR Pointer:ADDRESS;Size:LONGINT;Reqs:MemReqSet;ExitIfFails:BOOLEAN);
  39. VAR     Retry:BOOLEAN;
  40.  
  41.   PROCEDURE LowMemWarning(VAR Answer:BOOLEAN);
  42.   BEGIN
  43.     IF ExitIfFails THEN
  44.       Answer:=YesNoRequest(ADR(Warning),ADR(RETRY),ADR(ABORT));
  45.       IF NOT Answer THEN
  46.         ExitQuiet
  47.         (* procedure will never return *)
  48.       END;
  49.     ELSE
  50.       Answer:=YesNoRequest(ADR(Warning),ADR(RETRY),ADR(CANCEL));
  51.     END;
  52.   END LowMemWarning;
  53.  
  54. BEGIN
  55.   REPEAT
  56.     Forbid;
  57.     Pointer:=AllocTaskMem(Size,Reqs);
  58.     IF Pointer=NIL THEN
  59.       Permit;
  60.       LowMemWarning(Retry);
  61.     ELSIF AvailMem(MemReqSet{chip,largest})<minMemory THEN
  62.       DeallocTaskMem(Pointer);
  63.       Permit;
  64.       LowMemWarning(Retry);
  65.     ELSE
  66.       Permit;
  67.     END;
  68.   UNTIL (Pointer#NIL)OR NOT Retry;
  69. END Alloc;
  70.  
  71. PROCEDURE Allocate(VAR Pointer:ADDRESS;Size:LONGINT);
  72. BEGIN
  73.   Alloc(Pointer,Size,ANY,FALSE);
  74. END Allocate;
  75.  
  76. PROCEDURE AllocMem(VAR Pointer:ADDRESS;Size:LONGINT;Chip:BOOLEAN);
  77. BEGIN
  78.   IF Chip THEN
  79.     Alloc(Pointer,Size,CHIP,FALSE);
  80.   ELSE
  81.     Alloc(Pointer,Size,ANY,FALSE);
  82.   END;
  83. END AllocMem;
  84.  
  85. PROCEDURE Deallocate(VAR Pointer:ADDRESS);
  86. BEGIN
  87.   DeallocTaskMem(Pointer);
  88.   Assert(Pointer=NIL,ADR(TwiceFreed));
  89. END Deallocate;
  90.  
  91. PROCEDURE NoCareAllocate(VAR Pointer:ADDRESS;Size:LONGINT);
  92. BEGIN
  93.   Alloc(Pointer,Size,ANY,TRUE);
  94. END NoCareAllocate;
  95.  
  96. PROCEDURE NoCareAllocMem(VAR Pointer:ADDRESS;Size:LONGINT;Chip:BOOLEAN);
  97. BEGIN
  98.   IF Chip THEN
  99.     Alloc(Pointer,Size,CHIP,TRUE);
  100.   ELSE
  101.     Alloc(Pointer,Size,ANY,TRUE);
  102.   END;
  103. END NoCareAllocMem;
  104.  
  105. PROCEDURE NoCareDeallocate(VAR Pointer:ADDRESS);
  106. BEGIN
  107.   IF Pointer#NIL THEN
  108.     DeallocTaskMem(Pointer);
  109.   END;
  110. END NoCareDeallocate;
  111.  
  112. PROCEDURE EnterLevel(VAR Level:LevelKey);
  113. VAR     Task:TaskPtr;
  114. BEGIN
  115.   Task:=FindTask(NIL);
  116.   INC(CAST(UByte,Task^.memEntry.pad));
  117.   Level:=LONGINT(CAST(UByte,Task^.memEntry.pad));
  118. END EnterLevel;
  119.  
  120. PROCEDURE ExitLevel(VAR Level:LevelKey);
  121. VAR     Task:TaskPtr;
  122.         Entry:MemListPtr;
  123. BEGIN
  124.   Task:=FindTask(NIL);
  125.   WITH Task^.memEntry DO
  126.     IF Level<=LONGINT(CAST(UByte,pad)) THEN
  127.       pad:=CAST(BYTE,UByte(Level-1));
  128.       LOOP
  129.         Entry:=ADDRESS(head);
  130.         IF Entry^.node.succ=NIL THEN
  131.           EXIT
  132.         ELSIF LONGINT(CAST(UByte,Entry^.node.pri))<Level THEN
  133.           EXIT
  134.         END;
  135.         Remove(head);
  136.         FreeEntry(Entry);
  137.       END; (* loop *)
  138.     END; (* loop *)
  139.   END; (* with *)
  140. END ExitLevel;
  141.  
  142. END MemSystem.
  143.  
  144.